home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / src / pl-fli.c < prev    next >
Encoding:
C/C++ Source or Header  |  1998-02-18  |  38.0 KB  |  2,156 lines
  1. /*  $Id: pl-fli.c,v 1.27 1998/02/18 13:56:52 jan Exp $
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: Virtual machine instruction interpreter
  8. */
  9.  
  10. /*#define O_SECURE 1*/
  11. /*#define O_DEBUG 1*/
  12. #include "pl-incl.h"
  13.  
  14. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  15. SWI-Prolog  new-style  foreign-language  interface.   This  new  foreign
  16. interface is a mix of the old  interface using the ideas on term-handles
  17. from  Quintus  Prolog.  Term-handles  are    integers  (unsigned  long),
  18. describing the offset of the term-location relative   to the base of the
  19. local stack.
  20.  
  21. If a C-function has to  store  intermediate   results,  it  can do so by
  22. creating a new term-reference using   PL_new_term_ref().  This functions
  23. allocates a cell on the local stack and returns the offset.
  24.  
  25. While a foreign function is on top of  the stack, the local stacks looks
  26. like this:
  27.  
  28.                               | <-- lTop
  29.     -----------------------------------------------
  30.     | Allocated term-refs using PL_new_term_ref() |
  31.     -----------------------------------------------
  32.     | reserved for #term-refs (1)              |
  33.     -----------------------------------------------
  34.     | foreign-function arguments (term-refs)      |
  35.     -----------------------------------------------
  36.     | Local frame of foreign function             |
  37.     -----------------------------------------------
  38.  
  39. On a call-back to Prolog using  PL_call(),  etc., (1) is filled with the
  40. number of term-refs allocated. This  information   (stored  as  a tagged
  41. Prolog int) is used by the garbage collector to update the stack frames.
  42. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  43.  
  44. #if O_SECURE
  45. #define setHandle(h, w)        { assert(*valTermRef(h) != QID_MAGIC); \
  46.                   (*valTermRef(h) = (w)); \
  47.                 }
  48. #else
  49. #define setHandle(h, w)        (*valTermRef(h) = (w))
  50. #endif
  51. #define valHandleP(h)        valTermRef(h)
  52.  
  53. #undef ulong
  54. #define ulong unsigned long
  55.  
  56. static inline word
  57. valHandle(term_t r)
  58. { Word p = valTermRef(r);
  59.  
  60.   deRef(p);
  61.   return *p;
  62. }
  63.  
  64.  
  65.          /*******************************
  66.          *       CREATE/RESET        *
  67.          *******************************/
  68.  
  69. #undef PL_new_term_refs
  70. #undef PL_new_term_ref
  71. #undef PL_reset_term_refs
  72.  
  73. term_t
  74. PL_new_term_refs(int n)
  75. { Word t = (Word)lTop;
  76.   term_t r = consTermRef(t);
  77.  
  78.   lTop = (LocalFrame)(t+n);
  79.   verifyStack(local);
  80.  
  81.   while(n-- > 0)
  82.   { SECURE(assert(*t != QID_MAGIC));
  83.     setVar(*t++);
  84.   }
  85.   
  86.   return r;
  87. }
  88.  
  89.  
  90. term_t
  91. PL_new_term_ref()
  92. { Word t = (Word)lTop;
  93.   term_t r = consTermRef(t);
  94.  
  95.   lTop = (LocalFrame)(t+1);
  96.   verifyStack(local);
  97.   SECURE(assert(*t != QID_MAGIC));
  98.   setVar(*t);
  99.   
  100.   return r;
  101. }
  102.  
  103.  
  104. void
  105. PL_reset_term_refs(term_t r)
  106. { lTop = (LocalFrame) valTermRef(r);
  107. }
  108.  
  109.  
  110. term_t
  111. PL_copy_term_ref(term_t from)
  112. { Word t   = (Word)lTop;
  113.   term_t r = consTermRef(t);
  114.   Word p2  = valHandleP(from);
  115.  
  116.   lTop = (LocalFrame)(t+1);
  117.   verifyStack(local);
  118.   deRef(p2);
  119.   *t = isVar(*p2) ? makeRef(p2) : *p2;
  120.   
  121.   return r;
  122. }
  123.  
  124.  
  125.          /*******************************
  126.          *           ATOMS        *
  127.          *******************************/
  128.  
  129. atom_t
  130. PL_new_atom(const char *s)
  131. { return (atom_t) lookupAtom((char *)s); /* hack */
  132. }
  133.  
  134.  
  135. const char *
  136. PL_atom_chars(atom_t a)
  137. { return (const char *) stringAtom(a);
  138. }
  139.  
  140.  
  141. functor_t
  142. PL_new_functor(atom_t f,  int a)
  143. { return lookupFunctorDef(f, a);
  144. }
  145.  
  146.  
  147. atom_t
  148. PL_functor_name(functor_t f)
  149. { return nameFunctor(f);
  150. }
  151.  
  152.  
  153. int
  154. PL_functor_arity(functor_t f)
  155. { return arityFunctor(f);
  156. }
  157.  
  158.  
  159.          /*******************************
  160.          *    QUINTUS WRAPPER SUPPORT   *
  161.          *******************************/
  162.  
  163. bool
  164. PL_cvt_i_integer(term_t p, long *c)
  165. { return PL_get_long(p, c);
  166. }
  167.  
  168.  
  169. bool
  170. PL_cvt_i_float(term_t p, double *c)
  171. { return PL_get_float(p, c);
  172. }
  173.  
  174.  
  175. bool
  176. PL_cvt_i_single(term_t p, float *c)
  177. { double f;
  178.  
  179.   if ( PL_get_float(p, &f) )
  180.   { *c = (float)f;
  181.     succeed;
  182.   }
  183.  
  184.   fail;
  185. }
  186.  
  187.  
  188. bool
  189. PL_cvt_i_string(term_t p, char **c)
  190. { return PL_get_chars(p, c, CVT_ATOM|CVT_STRING);
  191. }
  192.  
  193.  
  194. bool
  195. PL_cvt_i_atom(term_t p, atom_t *c)
  196. { return PL_get_atom(p, c);
  197. }
  198.  
  199.  
  200. bool
  201. PL_cvt_o_integer(long c, term_t p)
  202. { return PL_unify_integer(p, c);
  203. }
  204.  
  205.  
  206. bool
  207. PL_cvt_o_float(double c, term_t p)
  208. { return PL_unify_float(p, c);
  209. }
  210.  
  211.  
  212. bool
  213. PL_cvt_o_single(float c, term_t p)
  214. { return PL_unify_float(p, c);
  215. }
  216.  
  217.  
  218. bool
  219. PL_cvt_o_string(const char *c, term_t p)
  220. { return PL_unify_atom_chars(p, c);
  221. }
  222.  
  223.  
  224. bool
  225. PL_cvt_o_atom(atom_t c, term_t p)
  226. { return PL_unify_atom(p, c);
  227. }
  228.  
  229.  
  230.          /*******************************
  231.          *          COMPARE        *
  232.          *******************************/
  233.  
  234. int
  235. PL_compare(term_t t1, term_t t2)
  236. { Word p1 = valHandleP(t1);
  237.   Word p2 = valHandleP(t2);
  238.  
  239.   return compareStandard(p1, p2);    /* -1, 0, 1 */
  240. }
  241.  
  242.  
  243.          /*******************************
  244.          *          INTEGERS        *
  245.          *******************************/
  246.  
  247. word
  248. makeNum(long i)
  249. { if ( inTaggedNumRange(i) )
  250.     return consInt(i);
  251.  
  252.   return globalLong(i);
  253. }
  254.  
  255.  
  256.          /*******************************
  257.          *           CONS-*        *
  258.          *******************************/
  259.  
  260. void
  261. PL_cons_functor(term_t h, functor_t fd, ...)
  262. { int arity = arityFunctor(fd);
  263.  
  264.   if ( arity == 0 )
  265.   { setHandle(h, nameFunctor(fd));
  266.   } else
  267.   { Word a = allocGlobal(1 + arity);
  268.     va_list args;
  269.  
  270.     va_start(args, fd);
  271.     setHandle(h, consPtr(a, TAG_COMPOUND|STG_GLOBAL));
  272.     *a++ = fd;
  273.     while(arity-- > 0)
  274.     { term_t r = va_arg(args, term_t);
  275.       Word p = valHandleP(r);
  276.  
  277.       deRef(p);
  278.       *a++ = (isVar(*p) ? makeRef(p) : *p);
  279.     }
  280.     va_end(args);
  281.   }
  282. }
  283.  
  284.  
  285. void
  286. PL_cons_list(term_t l, term_t head, term_t tail)
  287. { Word a = allocGlobal(3);
  288.   Word p;
  289.   
  290.   a[0] = FUNCTOR_dot2;
  291.   p = valHandleP(head);
  292.   deRef(p);
  293.   a[1] = (isVar(*p) ? makeRef(p) : *p);
  294.   p = valHandleP(tail);
  295.   deRef(p);
  296.   a[2] = (isVar(*p) ? makeRef(p) : *p);
  297.  
  298.   setHandle(l, consPtr(a, TAG_COMPOUND|STG_GLOBAL));
  299. }
  300.  
  301.          /*******************************
  302.          *     POINTER <-> PROLOG INT    *
  303.          *******************************/
  304.  
  305. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  306. Pointers are not a special type in Prolog. Instead, they are represented
  307. by an integer. The funtions below convert   integers  such that they can
  308. normally be expressed as a tagged  integer: the heap_base is subtracted,
  309. it is divided by 4 and the low 2   bits  are placed at the top (they are
  310. normally 0). longToPointer() does the inverse operation.
  311. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  312.  
  313. static ulong
  314. pointerToLong(void *ptr)
  315. { ulong p = (ulong) ptr;
  316.   ulong low = p & 0x3L;
  317.  
  318.   p -= heap_base;
  319.   p >>= 2;
  320.   p |= low<<(sizeof(ulong)*8-2);
  321.   
  322.   return p;
  323. }
  324.  
  325.  
  326. static void *
  327. longToPointer(ulong p)
  328. { ulong low = p >> (sizeof(ulong)*8-2);
  329.  
  330.   p <<= 2;
  331.   p |= low;
  332.   p += heap_base;
  333.  
  334.   return (void *) p;
  335. }
  336.  
  337.  
  338.          /*******************************
  339.          *          GET-*        *
  340.          *******************************/
  341.  
  342. int
  343. PL_get_atom(term_t t, atom_t *a)
  344. { word w = valHandle(t);
  345.  
  346.   if ( isAtom(w) )
  347.   { *a = (atom_t) w;
  348.     succeed;
  349.   }
  350.   fail;
  351. }
  352.  
  353.  
  354. int
  355. PL_get_atom_chars(term_t t, char **s)
  356. { word w = valHandle(t);
  357.  
  358.   if ( isAtom(w) )
  359.   { *s = stringAtom(w);
  360.     succeed;
  361.   }
  362.   fail;
  363. }
  364.  
  365. #ifdef O_STRING
  366. int
  367. PL_get_string(term_t t, char **s, int *len)
  368. { word w = valHandle(t);
  369.  
  370.   if ( isString(w) )
  371.   { *s = valString(w);
  372.     *len = sizeString(w);
  373.     succeed;
  374.   }
  375.   fail;
  376. }
  377. #endif
  378.  
  379. #define discardable_buffer     (LD->fli._discardable_buffer)
  380. #define buffer_ring        (LD->fli._buffer_ring)
  381. #define current_buffer_id    (LD->fli._current_buffer_id)
  382.  
  383. static Buffer
  384. findBuffer(int flags)
  385. { Buffer b;
  386.  
  387.   if ( flags & BUF_RING )
  388.   { if ( ++current_buffer_id == BUFFER_RING_SIZE )
  389.       current_buffer_id = 0;
  390.     b = &buffer_ring[current_buffer_id];
  391.   } else
  392.     b = &discardable_buffer;
  393.  
  394.   if ( !b->base )
  395.     initBuffer(b);
  396.  
  397.   emptyBuffer(b);
  398.   return b;
  399. }
  400.  
  401.  
  402. char *
  403. buffer_string(const char *s, int flags)
  404. { Buffer b = findBuffer(flags);
  405.   int l = strlen(s) + 1;
  406.  
  407.   addMultipleBuffer(b, s, l, char);
  408.  
  409.   return baseBuffer(b, char);
  410. }
  411.  
  412.  
  413. static int
  414. unfindBuffer(int flags)
  415. { if ( flags & BUF_RING )
  416.   { if ( --current_buffer_id <= 0 )
  417.       current_buffer_id = BUFFER_RING_SIZE-1;
  418.   }
  419.  
  420.   fail;
  421. }
  422.  
  423.  
  424. static char *
  425. malloc_string(const char *s)
  426. { char *c;
  427.   int len = strlen(s)+1;
  428.  
  429.   if ( (c = malloc(len)) )
  430.   { memcpy(c, s, len);
  431.     return c;
  432.   }
  433.  
  434.   outOfCore();
  435.   return NULL;
  436. }
  437.  
  438.  
  439. int
  440. PL_get_list_chars(term_t l, char **s, unsigned flags)
  441. { Buffer b = findBuffer(flags);
  442.   word list = valHandle(l);
  443.   Word arg, tail;
  444.   int c;
  445.   char *r;
  446.  
  447.   while( isList(list) && !isNil(list) )
  448.   { arg = argTermP(list, 0);
  449.     deRef(arg);
  450.     if ( isTaggedInt(*arg) && (c=(int)valInt(*arg)) > 0 && c < 256)
  451.     { addBuffer(b, c, char);
  452.       tail = argTermP(list, 1);
  453.       deRef(tail);
  454.       list = *tail;
  455.       continue;
  456.     }
  457.     return unfindBuffer(flags);
  458.   }
  459.   if (!isNil(list))
  460.     return unfindBuffer(flags);
  461.  
  462.   addBuffer(b, EOS, char);
  463.   r = baseBuffer(b, char);
  464.  
  465.   if ( flags & BUF_MALLOC )
  466.     *s = malloc_string(r);
  467.   else
  468.     *s = r;
  469.  
  470.   succeed;
  471. }
  472.  
  473.  
  474. int
  475. PL_get_chars(term_t l, char **s, unsigned flags)
  476. { word w = valHandle(l);
  477.   char tmp[24];
  478.   char *r;
  479.   int type;
  480.  
  481.   if ( (flags & CVT_ATOM) && isAtom(w) )
  482.   { type = PL_ATOM;
  483.     r = stringAtom(w);
  484.   } else if ( (flags & CVT_INTEGER) && isInteger(w) )
  485.   { type = PL_INTEGER;
  486.     Ssprintf(tmp, "%ld", valInteger(w) );
  487.     r = tmp;
  488.   } else if ( (flags & CVT_FLOAT) && isReal(w) )
  489.   { type = PL_FLOAT;
  490.     Ssprintf(tmp, "%f", valReal(w) );
  491.     r = tmp;
  492. #ifdef O_STRING
  493.   } else if ( (flags & CVT_STRING) && isString(w) )
  494.   { type = PL_STRING;
  495.     r = valString(w);
  496. #endif
  497.   } else if ( (flags & CVT_LIST) )
  498.   { return PL_get_list_chars(l, s, flags);
  499.   } else if ( (flags & CVT_VARIABLE) )
  500.   { type = PL_VARIABLE;
  501.     r = varName(l, tmp);
  502.   } else
  503.     fail;
  504.     
  505.   if ( flags & BUF_MALLOC )
  506.   { *s = malloc_string(r);
  507.   } else if ( ((flags & BUF_RING) && type != PL_ATOM) || /* never atoms */
  508.           (type == PL_STRING) ||    /* always buffer strings */
  509.           r == tmp )        /* always buffer tmp */
  510.   { Buffer b = findBuffer(flags);
  511.     int l = strlen(r) + 1;
  512.  
  513.     addMultipleBuffer(b, r, l, char);
  514.     *s = baseBuffer(b, char);
  515.   } else
  516.     *s = r;
  517.  
  518.   succeed;
  519. }
  520.  
  521.  
  522. int
  523. PL_get_integer(term_t t, int *i)
  524. { word w = valHandle(t);
  525.   
  526.   if ( isTaggedInt(w) )
  527.   { *i = valInt(w);
  528.     succeed;
  529.   }
  530.   if ( isBignum(w) )
  531.   { *i = valBignum(w);
  532.     succeed;
  533.   }
  534.   if ( isReal(w) )
  535.   { real f = valReal(w);
  536.     long l;
  537.  
  538. #ifdef DOUBLE_TO_LONG_CAST_RAISES_SIGFPE
  539.     if ( !((f >= PLMININT) && (f <= PLMAXINT)) )
  540.       fail;
  541. #endif
  542.  
  543.     l = (long)f;
  544.     if ( (real)l == f )
  545.     { *i = l;
  546.       succeed;
  547.     }
  548.   }
  549.   fail;
  550. } 
  551.  
  552.  
  553. int
  554. PL_get_long(term_t t, long *i)
  555. { word w = valHandle(t);
  556.   
  557.   if ( isTaggedInt(w) )
  558.   { *i = valInt(w);
  559.     succeed;
  560.   }
  561.   if ( isBignum(w) )
  562.   { *i = valBignum(w);
  563.     succeed;
  564.   }
  565.   if ( isReal(w) )
  566.   { real f = valReal(w);
  567.     long l;
  568.     
  569. #ifdef DOUBLE_TO_LONG_CAST_RAISES_SIGFPE
  570.     if ( !((f >= PLMININT) && (f <= PLMAXINT)) )
  571.       fail;
  572. #endif
  573.  
  574.     l = (long) f;
  575.     if ( (real)l == f )
  576.     { *i = l;
  577.       succeed;
  578.     }
  579.   }
  580.   fail;
  581. } 
  582.  
  583.  
  584. int
  585. PL_get_float(term_t t, double *f)
  586. { word w = valHandle(t);
  587.   
  588.   if ( isReal(w) )
  589.   { *f = valReal(w);
  590.     succeed;
  591.   }
  592.   if ( isTaggedInt(w) )
  593.   { *f = (double) valInt(w);
  594.     succeed;
  595.   }
  596.   if ( isBignum(w) )
  597.   { *f = (double) valBignum(w);
  598.     succeed;
  599.   }
  600.   fail;
  601. }
  602.  
  603.  
  604. int
  605. PL_get_pointer(term_t t, void **ptr)
  606. { long p;
  607.  
  608.   if ( PL_get_long(t, &p) )
  609.   { *ptr = longToPointer((ulong)p);
  610.  
  611.     succeed;
  612.   }
  613.  
  614.   fail;
  615. } 
  616.  
  617.  
  618.  
  619. int
  620. PL_get_name_arity(term_t t, atom_t *name, int *arity)
  621. { word w = valHandle(t);
  622.  
  623.   if ( isTerm(w) )
  624.   { FunctorDef fd = valueFunctor(functorTerm(w));
  625.  
  626.     *name =  fd->name;
  627.     *arity = fd->arity;
  628.     succeed;
  629.   }
  630.   if ( isAtom(w) )
  631.   { *name = (atom_t)w;
  632.     *arity = 0;
  633.     succeed;
  634.   }
  635.  
  636.   fail;
  637. }
  638.  
  639.  
  640. int
  641. _PL_get_name_arity(term_t t, atom_t *name, int *arity)
  642. { word w = valHandle(t);
  643.  
  644.   if ( isTerm(w) )
  645.   { FunctorDef fd = valueFunctor(functorTerm(w));
  646.  
  647.     *name =  fd->name;
  648.     *arity = fd->arity;
  649.     succeed;
  650.   }
  651.  
  652.   fail;
  653. }
  654.  
  655.  
  656. int
  657. PL_get_functor(term_t t, functor_t *f)
  658. { word w = valHandle(t);
  659.  
  660.   if ( isTerm(w) )
  661.   { *f = functorTerm(w);
  662.     succeed;
  663.   }
  664.   if ( isAtom(w) )
  665.   { *f = lookupFunctorDef(w, 0);
  666.     succeed;
  667.   }
  668.  
  669.   fail;
  670. }
  671.  
  672.  
  673. int
  674. PL_get_module(term_t t, module_t *m)
  675. { atom_t a;
  676.  
  677.   if ( PL_get_atom(t, &a) )
  678.   { *m = lookupModule(a);
  679.     succeed;
  680.   }
  681.  
  682.   fail;
  683. }
  684.  
  685.  
  686. void
  687. _PL_get_arg(int index, term_t t, term_t a)
  688. { word w = valHandle(t);
  689.   Functor f = (Functor)valPtr(w);
  690.   Word p = &f->arguments[index-1];
  691.  
  692.   deRef(p);
  693.  
  694.   if ( isVar(*p) )
  695.     w = consPtr(p, TAG_REFERENCE|storage(w)); /* makeRef() */
  696.   else
  697.     w = *p;
  698.  
  699.   setHandle(a, w);
  700. }
  701.  
  702.  
  703. int
  704. PL_get_arg(int index, term_t t, term_t a)
  705. { word w = valHandle(t);
  706.  
  707.   if ( isTerm(w) && index > 0 )
  708.   { Functor f = (Functor)valPtr(w);
  709.     int arity = arityFunctor(f->definition);
  710.  
  711.     if ( --index < arity )
  712.     { Word p = &f->arguments[index];
  713.  
  714.       deRef(p);
  715.  
  716.       if ( isVar(*p) )
  717.     w = makeRef(p);
  718.       else
  719.     w = *p;
  720.  
  721.       setHandle(a, w);
  722.       succeed;
  723.     }
  724.   }
  725.  
  726.   fail;
  727. }
  728.  
  729.  
  730. int
  731. PL_get_list(term_t l, term_t h, term_t t)
  732. { word w = valHandle(l);
  733.  
  734.   if ( isList(w) )
  735.   { Word p1, p2;
  736.     
  737.     p1 = argTermP(w, 0);
  738.     p2 = argTermP(w, 1);
  739.     deRef(p1);
  740.     deRef(p2);
  741.     setHandle(h, isVar(*p1) ? makeRef(p1) : *p1);
  742.     setHandle(t, isVar(*p2) ? makeRef(p2) : *p2);
  743.     succeed;
  744.   }
  745.   fail;
  746. }
  747.  
  748.  
  749. int
  750. PL_get_head(term_t l, term_t h)
  751. { word w = valHandle(l);
  752.  
  753.   if ( isList(w) )
  754.   { Word p;
  755.     
  756.     p = argTermP(w, 0);
  757.     deRef(p);
  758.     setHandle(h, *p ? *p : makeRef(p));
  759.     succeed;
  760.   }
  761.   fail;
  762. }
  763.  
  764.  
  765. int
  766. PL_get_tail(term_t l, term_t t)
  767. { word w = valHandle(l);
  768.  
  769.   if ( isList(w) )
  770.   { Word p;
  771.     
  772.     p = argTermP(w, 1);
  773.     deRef(p);
  774.     setHandle(t, *p ? *p : makeRef(p));
  775.     succeed;
  776.   }
  777.   fail;
  778. }
  779.  
  780.  
  781. int
  782. PL_get_nil(term_t l)
  783. { word w = valHandle(l);
  784.  
  785.   if ( isNil(w) )
  786.     succeed;
  787.  
  788.   fail;
  789. }
  790.  
  791.  
  792. int
  793. _PL_get_xpce_reference(term_t t, xpceref_t *ref)
  794. { word w = valHandle(t);
  795.  
  796.   if ( hasFunctor(w, FUNCTOR_xpceref1) )
  797.   { Word p = argTermP(w, 0);
  798.  
  799.     do
  800.     { if ( isTaggedInt(*p) )
  801.       { ref->type    = PL_INTEGER;
  802.     ref->value.i = valInt(*p);
  803.  
  804.     succeed;
  805.       } 
  806.       if ( isAtom(*p) )
  807.       { ref->type    = PL_ATOM;
  808.     ref->value.a = (atom_t) *p;
  809.  
  810.     succeed;
  811.       }
  812.       if ( isBignum(*p) )
  813.       { ref->type    = PL_INTEGER;
  814.     ref->value.i = valBignum(*p);
  815.  
  816.     succeed;
  817.       }
  818.     } while(isRef(*p) && (p = unRef(*p)));
  819.  
  820.     return -1;                /* error! */
  821.   }
  822.  
  823.   fail;
  824. }
  825.  
  826.  
  827.          /*******************************
  828.          *        IS-*        *
  829.          *******************************/
  830.  
  831. int
  832. PL_is_variable(term_t t)
  833. { word w = valHandle(t);
  834.  
  835.   return isVar(w) ? TRUE : FALSE;
  836. }
  837.  
  838.  
  839. int
  840. PL_is_atom(term_t t)
  841. { word w = valHandle(t);
  842.  
  843.   return isAtom(w) ? TRUE : FALSE;
  844. }
  845.  
  846.  
  847. int
  848. PL_is_integer(term_t t)
  849. { word w = valHandle(t);
  850.  
  851.   return isInteger(w) ? TRUE : FALSE;
  852. }
  853.  
  854.  
  855. int
  856. PL_is_float(term_t t)
  857. { word w = valHandle(t);
  858.  
  859.   return isReal(w) ? TRUE : FALSE;
  860. }
  861.  
  862.  
  863. int
  864. PL_is_compound(term_t t)
  865. { word w = valHandle(t);
  866.  
  867.   return isTerm(w) ? TRUE : FALSE;
  868. }
  869.  
  870.  
  871. int
  872. PL_is_functor(term_t t, functor_t f)
  873. { word w = valHandle(t);
  874.  
  875.   if ( hasFunctor(w, f) )
  876.     succeed;
  877.  
  878.   fail;
  879. }
  880.  
  881.  
  882. int
  883. PL_is_list(term_t t)
  884. { word w = valHandle(t);
  885.  
  886.   return (isList(w) || isNil(w)) ? TRUE : FALSE;
  887. }
  888.  
  889.  
  890. int
  891. PL_is_atomic(term_t t)
  892. { word w = valHandle(t);
  893.  
  894.   return isAtomic(w) ? TRUE : FALSE;
  895. }
  896.  
  897.  
  898. int
  899. PL_is_number(term_t t)
  900. { word w = valHandle(t);
  901.  
  902.   return isNumber(w) ? TRUE : FALSE;
  903. }
  904.  
  905.  
  906. #ifdef O_STRING
  907. int
  908. PL_is_string(term_t t)
  909. { word w = valHandle(t);
  910.  
  911.   return isString(w) ? TRUE : FALSE;
  912. }
  913.  
  914. int
  915. PL_unify_string_chars(term_t t, const char *s)
  916. { word str = globalString((char *)s);
  917.   Word p = valHandleP(t);
  918.  
  919.   return unifyAtomic(p, str);
  920. }
  921.  
  922. int
  923. PL_unify_string_nchars(term_t t, int len, const char *s)
  924. { word str = globalNString(len, (char *)s);
  925.   Word p = valHandleP(t);
  926.  
  927.   return unifyAtomic(p, str);
  928. }
  929.  
  930. #endif
  931.  
  932.          /*******************************
  933.          *             PUT-*          *
  934.          *******************************/
  935.  
  936. void
  937. PL_put_variable(term_t t)
  938. { Word p = allocGlobal(1);
  939.  
  940.   setVar(*p);
  941.   setHandle(t, makeRef(p));
  942. }
  943.  
  944.  
  945. void
  946. PL_put_atom(term_t t, atom_t a)
  947. { setHandle(t, a);
  948. }
  949.  
  950.  
  951. void
  952. PL_put_atom_chars(term_t t, const char *s)
  953. { setHandle(t, lookupAtom(s));
  954. }
  955.  
  956.  
  957. void
  958. PL_put_string_chars(term_t t, const char *s)
  959. { word w = globalString(s);
  960.  
  961.   setHandle(t, w);
  962. }
  963.  
  964. void
  965. PL_put_list_chars(term_t t, const char *chars)
  966. { int len = strlen(chars);
  967.   
  968.   if ( len == 0 )
  969.   { setHandle(t, ATOM_nil);
  970.   } else
  971.   { Word p = allocGlobal(len*3);
  972.     setHandle(t, consPtr(p, TAG_COMPOUND|STG_GLOBAL));
  973.  
  974.     for( ; *chars ; chars++)
  975.     { *p++ = FUNCTOR_dot2;
  976.       *p++ = consInt((long)*chars & 0xff);
  977.       *p = consPtr(p+1, TAG_COMPOUND|STG_GLOBAL);
  978.       p++;
  979.     }
  980.     p[-1] = ATOM_nil;
  981.   }
  982. }
  983.  
  984. void
  985. PL_put_integer(term_t t, long i)
  986. { setHandle(t, makeNum(i));
  987. }
  988.  
  989.  
  990. void
  991. _PL_put_number(term_t t, Number n)
  992. { if ( intNumber(n) )
  993.     PL_put_integer(t, n->value.i);
  994.   else
  995.     PL_put_float(t, n->value.f);
  996. }
  997.  
  998.  
  999. void
  1000. PL_put_pointer(term_t t, void *ptr)
  1001. { PL_put_integer(t, pointerToLong(ptr));
  1002. }
  1003.  
  1004.  
  1005. void
  1006. PL_put_float(term_t t, double f)
  1007. { setHandle(t, globalReal(f));
  1008. }
  1009.  
  1010.  
  1011. void
  1012. PL_put_functor(term_t t, functor_t f)
  1013. { int arity = arityFunctor(f);
  1014.  
  1015.   if ( arity == 0 )
  1016.   { setHandle(t, nameFunctor(f));
  1017.   } else
  1018.   { Word a = allocGlobal(1 + arity);
  1019.  
  1020.     setHandle(t, consPtr(a, TAG_COMPOUND|STG_GLOBAL));
  1021.     *a++ = f;
  1022.     while(arity-- > 0)
  1023.       setVar(*a++);
  1024.   }
  1025. }
  1026.  
  1027.  
  1028. void
  1029. PL_put_list(term_t l)
  1030. { Word a = allocGlobal(3);
  1031.  
  1032.   setHandle(l, consPtr(a, TAG_COMPOUND|STG_GLOBAL));
  1033.   *a++ = FUNCTOR_dot2;
  1034.   setVar(*a++);
  1035.   setVar(*a);
  1036. }
  1037.  
  1038.  
  1039. void
  1040. PL_put_nil(term_t l)
  1041. { setHandle(l, ATOM_nil);
  1042. }
  1043.  
  1044.  
  1045. void
  1046. PL_put_term(term_t t1, term_t t2)
  1047. { Word p2 = valHandleP(t2);
  1048.  
  1049.   deRef(p2);
  1050.   setHandle(t1, isVar(*p2) ? makeRef(p2) : *p2);
  1051. }
  1052.  
  1053.  
  1054. void
  1055. _PL_put_xpce_reference_i(term_t t, unsigned long r)
  1056. { Word a = allocGlobal(2);
  1057.  
  1058.   setHandle(t, consPtr(a, TAG_COMPOUND|STG_GLOBAL));
  1059.   *a++ = FUNCTOR_xpceref1;
  1060.   *a++ = makeNum(r);
  1061. }
  1062.  
  1063.  
  1064. void
  1065. _PL_put_xpce_reference_a(term_t t, atom_t name)
  1066. { Word a = allocGlobal(2);
  1067.  
  1068.   setHandle(t, consPtr(a, TAG_COMPOUND|STG_GLOBAL));
  1069.   *a++ = FUNCTOR_xpceref1;
  1070.   *a++ = name;
  1071. }
  1072.  
  1073.  
  1074.          /*******************************
  1075.          *           UNIFY        *
  1076.          *******************************/
  1077.  
  1078. int
  1079. PL_unify_atom(term_t t, atom_t a)
  1080. { Word p = valHandleP(t);
  1081.  
  1082.   return unifyAtomic(p, a);
  1083. }
  1084.  
  1085.  
  1086. int
  1087. PL_unify_functor(term_t t, functor_t f)
  1088. { Word p = valHandleP(t);
  1089.   int arity = arityFunctor(f);
  1090.  
  1091.   deRef(p);
  1092.   if ( isVar(*p) )
  1093.   { if ( arity == 0 )
  1094.     { *p = nameFunctor(f);
  1095.     } else
  1096.     { 
  1097. #ifdef O_SHIFT_STACKS
  1098.       if ( !roomStack(global) > (1+arity) * sizeof(word) )
  1099.       { growStacks(environment_frame, NULL, FALSE, TRUE, FALSE);
  1100.     p = valHandleP(t);
  1101.     deRef(p);
  1102.       }
  1103. #else 
  1104.       requireStack(global, sizeof(word)*(1+arity));
  1105. #endif
  1106.  
  1107.       { Word a = gTop;
  1108.     gTop += 1+arity;
  1109.  
  1110.     *p = consPtr(a, TAG_COMPOUND|STG_GLOBAL);
  1111.     *a++ = f;
  1112.     for( ; arity > 0; a++, arity-- )
  1113.       setVar(*a);
  1114.       }
  1115.     }
  1116.  
  1117.     DoTrail(p);
  1118.     succeed;
  1119.   } else
  1120.   { if ( arity == 0  )
  1121.     { if ( *p == nameFunctor(f) )
  1122.     succeed;
  1123.     } else
  1124.     { if ( hasFunctor(*p, f) )
  1125.     succeed;
  1126.     }
  1127.  
  1128.     fail;
  1129.   }
  1130. }
  1131.  
  1132.  
  1133. int
  1134. PL_unify_atom_chars(term_t t, const char *chars)
  1135. { Word p = valHandleP(t);
  1136.  
  1137.   return unifyAtomic(p, lookupAtom((char *)chars));
  1138. }
  1139.  
  1140.  
  1141. int
  1142. PL_unify_list_chars(term_t l, const char *chars)
  1143. { term_t head = PL_new_term_ref();
  1144.   term_t t    = PL_copy_term_ref(l);
  1145.   int rval;
  1146.  
  1147.   for( ; *chars; chars++ )
  1148.   { if ( !PL_unify_list(t, head, t) ||
  1149.      !PL_unify_integer(head, (int)*chars & 0xff) )
  1150.       fail;
  1151.   }
  1152.  
  1153.   rval = PL_unify_nil(t);
  1154.   PL_reset_term_refs(head);
  1155.  
  1156.   return rval;
  1157. }
  1158.  
  1159.  
  1160. int
  1161. PL_unify_integer(term_t t, long i)
  1162. { Word p = valHandleP(t);
  1163.  
  1164.   return unifyAtomic(p, makeNum(i));
  1165. }
  1166.  
  1167.  
  1168. int
  1169. _PL_unify_number(term_t t, Number n)
  1170. { if ( intNumber(n) )
  1171.     return PL_unify_integer(t, n->value.i);
  1172.   else
  1173.     return PL_unify_float(t, n->value.f);
  1174. }
  1175.  
  1176.  
  1177. int
  1178. PL_unify_pointer(term_t t, void *ptr)
  1179. { return PL_unify_integer(t, pointerToLong(ptr));
  1180. }
  1181.  
  1182.  
  1183. int
  1184. PL_unify_float(term_t t, double f)
  1185. { word w = globalReal(f);
  1186.   Word p = valHandleP(t);
  1187.  
  1188.   return unifyAtomic(p, w);
  1189. }
  1190.  
  1191.  
  1192. int
  1193. PL_unify_arg(int index, term_t t, term_t a)
  1194. { word w = valHandle(t);
  1195.  
  1196.   if ( isTerm(w) &&
  1197.        index > 0 &&
  1198.        index <= (int)arityFunctor(functorTerm(w)) )
  1199.   { Word p = argTermP(w, index-1);
  1200.     Word p2 = valHandleP(a);
  1201.  
  1202.     return unify_ptrs(p, p2);
  1203.   }
  1204.  
  1205.   fail;
  1206. }
  1207.  
  1208.  
  1209. int                    /* can be faster! */
  1210. PL_unify_list(term_t l, term_t h, term_t t)
  1211. { if ( PL_unify_functor(l, FUNCTOR_dot2) )
  1212.   { PL_get_list(l, h, t);
  1213.  
  1214.     succeed;
  1215.   }
  1216.  
  1217.   fail;
  1218. }
  1219.  
  1220.  
  1221. int
  1222. PL_unify_nil(term_t l)
  1223. { Word p = valHandleP(l);
  1224.  
  1225.   return unifyAtomic(p, ATOM_nil);
  1226. }
  1227.  
  1228. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1229. Fixed by Franklin Chen <chen@adi.com> to   compile on MkLinux, where you
  1230. cannot assign to va_list as it is an array. Thanks!
  1231. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1232.  
  1233. typedef struct va_list_rec {
  1234.   va_list v;
  1235. } va_list_rec;
  1236.  
  1237. #define args argsRec.v
  1238.  
  1239. static int
  1240. unify_termVP(term_t t, va_list_rec *argsRecP)
  1241. { va_list_rec argsRec = *argsRecP;
  1242.   int rval;
  1243.  
  1244.   switch(va_arg(args, int))
  1245.   { case PL_VARIABLE:
  1246.       rval = TRUE;
  1247.       break;
  1248.     case PL_ATOM:
  1249.       rval = PL_unify_atom(t, va_arg(args, atom_t));
  1250.       break;
  1251.     case PL_INTEGER:
  1252.       rval = PL_unify_integer(t, va_arg(args, long));
  1253.       break;
  1254.     case PL_POINTER:
  1255.       rval = PL_unify_pointer(t, va_arg(args, void *));
  1256.       break;
  1257.     case PL_FLOAT:
  1258.       rval = PL_unify_float(t, va_arg(args, double));
  1259.       break;
  1260.     case PL_STRING:
  1261.       rval = PL_unify_string_chars(t, va_arg(args, const char *));
  1262.       break;
  1263.     case PL_TERM:
  1264.       rval = PL_unify(t, va_arg(args, term_t));
  1265.       break;
  1266.     case PL_CHARS:
  1267.       rval = PL_unify_atom_chars(t, va_arg(args, const char *));
  1268.       break;
  1269.     case PL_FUNCTOR:
  1270.     { functor_t ft = va_arg(args, functor_t);
  1271.       int arity = arityFunctor(ft);
  1272.       term_t tmp = PL_new_term_ref();
  1273.       int n;
  1274.  
  1275.       if ( !PL_unify_functor(t, ft) )
  1276.     goto failout;
  1277.  
  1278.       for(n=1; n<=arity; n++)
  1279.       {    _PL_get_arg(n, t, tmp);
  1280.     
  1281.     rval = unify_termVP(tmp, &argsRec);
  1282.     if ( !rval )
  1283.       goto failout;
  1284.       }
  1285.  
  1286.       rval = TRUE;
  1287.       PL_reset_term_refs(tmp);
  1288.       break;
  1289.     failout:
  1290.       rval = FALSE;
  1291.       PL_reset_term_refs(tmp);
  1292.       break;
  1293.     }
  1294.     case PL_LIST:
  1295.     { int length = va_arg(args, int);
  1296.       term_t tmp = PL_copy_term_ref(t);
  1297.       term_t h   = PL_new_term_ref();
  1298.  
  1299.       for( ; length-- > 0; )
  1300.       { PL_unify_list(tmp, h, tmp);
  1301.     rval = unify_termVP(h, &argsRec);
  1302.     if ( !rval )
  1303.       goto listfailout;
  1304.       }
  1305.  
  1306.       rval = PL_unify_nil(tmp);
  1307.       PL_reset_term_refs(tmp);
  1308.       break;
  1309.     listfailout:
  1310.       PL_reset_term_refs(tmp);
  1311.       break;
  1312.     }
  1313.     default:
  1314.       PL_warning("Format error in PL_unify_term()");
  1315.       rval = FALSE;
  1316.   }
  1317.  
  1318.   *argsRecP = argsRec;
  1319.   return rval;
  1320. }
  1321.  
  1322. int
  1323. PL_unify_term(term_t t, ...)
  1324. {
  1325.   va_list_rec argsRec;
  1326.   int rval;
  1327.  
  1328.   va_start(args, t);
  1329.   rval = unify_termVP(t, &argsRec);
  1330.   va_end(args);
  1331.  
  1332.   return rval;
  1333. }
  1334.  
  1335. #undef args
  1336.  
  1337. int
  1338. _PL_unify_xpce_reference(term_t t, xpceref_t *ref)
  1339. { Word p = valHandleP(t);
  1340.  
  1341.   do
  1342.   { if ( isVar(*p) )
  1343.     { Word a = allocGlobal(2);
  1344.   
  1345.       *p = consPtr(a, TAG_COMPOUND|STG_GLOBAL);
  1346.       DoTrail(p);
  1347.       *a++ = FUNCTOR_xpceref1;
  1348.       if ( ref->type == PL_INTEGER )
  1349.     *a++ = makeNum(ref->value.i);
  1350.       else
  1351.     *a++ = ref->value.a;
  1352.   
  1353.       succeed;
  1354.     } 
  1355.     if ( hasFunctor(*p, FUNCTOR_xpceref1) )
  1356.     { Word a = argTermP(*p, 0);
  1357.       word v = (ref->type == PL_INTEGER ? makeNum(ref->value.i)
  1358.                     : ref->value.a);
  1359.   
  1360.       deRef(a);
  1361.       return unifyAtomic(a, v);
  1362.     }
  1363.   } while ( isRef(*p) && (p = unRef(*p)));
  1364.  
  1365.   fail;
  1366. }
  1367.  
  1368.  
  1369.          /*******************************
  1370.          *       ATOMIC (INTERNAL)    *
  1371.          *******************************/
  1372.  
  1373. atomic_t
  1374. _PL_get_atomic(term_t t)
  1375. { return valHandle(t);
  1376. }
  1377.  
  1378.  
  1379. int
  1380. _PL_unify_atomic(term_t t, atomic_t a)
  1381. { Word p = valHandleP(t);
  1382.  
  1383.   return unifyAtomic(p, a);
  1384. }
  1385.  
  1386.  
  1387. void
  1388. _PL_put_atomic(term_t t, atomic_t a)
  1389. { setHandle(t, a);
  1390. }
  1391.  
  1392.  
  1393. void
  1394. _PL_copy_atomic(term_t t, atomic_t arg) /* internal one */
  1395. { word a;
  1396.  
  1397.   if ( isIndirect(arg) )
  1398.     a = globalIndirect(arg);
  1399.   else
  1400.     a = arg;
  1401.   
  1402.   setHandle(t, a);
  1403. }
  1404.  
  1405.  
  1406.          /*******************************
  1407.          *           TYPE        *
  1408.          *******************************/
  1409.  
  1410.  
  1411. int
  1412. PL_term_type(term_t t)
  1413. { word w = valHandle(t);
  1414.  
  1415.   if ( isVar(w) )        return PL_VARIABLE;
  1416.   if ( isInteger(w) )        return PL_INTEGER;
  1417.   if ( isReal(w) )        return PL_FLOAT;
  1418. #if O_STRING
  1419.   if ( isString(w) )        return PL_STRING;
  1420. #endif /* O_STRING */
  1421.   if ( isAtom(w) )        return PL_ATOM;
  1422.  
  1423.   assert(isTerm(w));
  1424.                   return PL_TERM;
  1425. }
  1426.  
  1427.          /*******************************
  1428.          *          UNIFY        *
  1429.          *******************************/
  1430.  
  1431. int
  1432. PL_unify(term_t t1, term_t t2)
  1433. { Word p1 = valHandleP(t1);
  1434.   Word p2 = valHandleP(t2);
  1435.   mark m;
  1436.   int rval;
  1437.  
  1438.   Mark(m);
  1439.   if ( !(rval = unify(p1, p2, environment_frame)) )
  1440.     Undo(m);
  1441.  
  1442.   return rval;  
  1443. }
  1444.  
  1445.  
  1446.          /*******************************
  1447.          *           MODULES        *
  1448.          *******************************/
  1449.  
  1450. int
  1451. PL_strip_module(term_t raw, module_t *m, term_t plain)
  1452. { Word r = valHandleP(raw);
  1453.   Word p;
  1454.  
  1455.   if ( (p = stripModule(r, m)) )
  1456.   { setHandle(plain, isVar(*p) ? makeRef(p) : *p);
  1457.     succeed;
  1458.   }
  1459.  
  1460.   fail;
  1461. }
  1462.  
  1463.         /********************************
  1464.         *            MODULES            *
  1465.         *********************************/
  1466.  
  1467. module_t
  1468. PL_context()
  1469. { return environment_frame ? contextModule(environment_frame)
  1470.                : MODULE_user;
  1471. }
  1472.  
  1473. atom_t
  1474. PL_module_name(Module m)
  1475. { return (atom_t) m->name;
  1476. }
  1477.  
  1478. module_t
  1479. PL_new_module(atom_t name)
  1480. { return lookupModule(name);
  1481. }
  1482.  
  1483.  
  1484.          /*******************************
  1485.          *        PREDICATES        *
  1486.          *******************************/
  1487.  
  1488. predicate_t
  1489. PL_pred(functor_t functor, module_t module)
  1490. { if ( module == NULL )
  1491.     module = PL_context();
  1492.  
  1493.   return lookupProcedure(functor, module);
  1494. }
  1495.  
  1496.  
  1497. predicate_t
  1498. PL_predicate(const char *name, int arity, const char *module)
  1499. { Module m = module ? lookupModule(lookupAtom(module)) : PL_context();
  1500.   functor_t f = lookupFunctorDef(lookupAtom(name), arity);
  1501.  
  1502.   return PL_pred(f, m);
  1503. }
  1504.  
  1505.  
  1506. predicate_t
  1507. _PL_predicate(const char *name, int arity, const char *module,
  1508.           predicate_t *bin)
  1509. { if ( !*bin )
  1510.     *bin = PL_predicate(name, arity, module);
  1511.  
  1512.   return *bin;
  1513. }
  1514.  
  1515.  
  1516. int
  1517. PL_predicate_info(predicate_t pred, atom_t *name, int *arity, module_t *m)
  1518. { if ( pred->type == PROCEDURE_TYPE )
  1519.   { *name  = pred->definition->functor->name;
  1520.     *arity = pred->definition->functor->arity;
  1521.     *m     = pred->definition->module;
  1522.  
  1523.     succeed;
  1524.   }
  1525.  
  1526.   fail;
  1527. }
  1528.  
  1529.          /*******************************
  1530.          *           CALLING        *
  1531.          *******************************/
  1532.  
  1533. int
  1534. PL_call_predicate(Module ctx, int flags, predicate_t pred, term_t h0)
  1535. { int rval;
  1536.  
  1537.   qid_t qid = PL_open_query(ctx, flags, pred, h0);
  1538.   rval = PL_next_solution(qid);
  1539.   PL_cut_query(qid);
  1540.  
  1541.   return rval;
  1542. }
  1543.  
  1544.  
  1545. bool
  1546. PL_call(term_t t, Module m)
  1547. { return callProlog(m, t, TRUE);
  1548. }  
  1549.  
  1550.  
  1551.         /********************************
  1552.         *     FOREIGNS RETURN        *
  1553.         ********************************/
  1554.  
  1555. foreign_t
  1556. _PL_retry(long v)
  1557. { ForeignRedoInt(v);
  1558. }
  1559.  
  1560.  
  1561. foreign_t
  1562. _PL_retry_address(void *v)
  1563. { if ( (ulong)v & FRG_CONTROL_MASK )
  1564.     PL_fatal_error("PL_retry_address(0x%lx): bad alignment", (ulong)v);
  1565.  
  1566.   ForeignRedoPtr(v);
  1567. }
  1568.  
  1569.  
  1570. long
  1571. PL_foreign_context(control_t h)
  1572. { return ForeignContextInt(h);
  1573. }
  1574.  
  1575. void *
  1576. PL_foreign_context_address(control_t h)
  1577. { return ForeignContextPtr(h);
  1578. }
  1579.  
  1580.  
  1581. int
  1582. PL_foreign_control(control_t h)
  1583. { return ForeignControl(h);
  1584. }
  1585.  
  1586.  
  1587. int
  1588. PL_throw(term_t exception)
  1589. { PL_put_term(exception_bin, exception);
  1590.  
  1591.   exception_term = exception_bin;
  1592.  
  1593.   fail;
  1594. }
  1595.  
  1596.         /********************************
  1597.         *      REGISTERING FOREIGNS     *
  1598.         *********************************/
  1599.  
  1600. static void
  1601. notify_registered_foreign(functor_t fd, Module m)
  1602. { if ( GD->initialised )
  1603.   { fid_t cid = PL_open_foreign_frame();
  1604.     term_t argv = PL_new_term_refs(2);
  1605.     predicate_t pred = _PL_predicate("$foreign_registered", 2, "system",
  1606.                      &GD->procedures.foreign_registered2);
  1607.  
  1608.     PL_put_atom(argv+0, m->name);
  1609.     PL_put_functor(argv+1, fd);
  1610.     PL_call_predicate(MODULE_system, FALSE, pred, argv);
  1611.     PL_discard_foreign_frame(cid);
  1612.   }
  1613. }
  1614.  
  1615.  
  1616. bool
  1617. PL_register_foreign(const char *name, int arity, Func f, int flags)
  1618. { Procedure proc;
  1619.   Definition def;
  1620.   Module m;
  1621.   functor_t fdef = lookupFunctorDef(lookupAtom(name), arity);
  1622.  
  1623.   m = (environment_frame ? contextModule(environment_frame)
  1624.              : MODULE_system);
  1625.  
  1626.   proc = lookupProcedure(lookupFunctorDef(lookupAtom(name), arity), m);
  1627.   def = proc->definition;
  1628.  
  1629.   if ( true(def, LOCKED) )
  1630.   { warning("PL_register_foreign(): Attempt to redefine a system predicate: %s",
  1631.         procedureName(proc));
  1632.     fail;
  1633.   }
  1634.  
  1635.   if ( def->definition.function )
  1636.     warning("PL_register_foreign(): redefined %s", procedureName(proc));
  1637.   if ( false(def, FOREIGN) && def->definition.clauses != NULL )
  1638.     abolishProcedure(proc, m);
  1639.  
  1640.   def->definition.function = f;
  1641.   def->indexPattern = 0;
  1642.   def->indexCardinality = 0;
  1643.   def->flags = 0;
  1644.   set(def, FOREIGN|TRACE_ME);
  1645.   clear(def, NONDETERMINISTIC);
  1646.  
  1647.   if ( (flags & PL_FA_NOTRACE) )      clear(def, TRACE_ME);
  1648.   if ( (flags & PL_FA_TRANSPARENT) )      set(def, METAPRED);
  1649.   if ( (flags & PL_FA_NONDETERMINISTIC) ) set(def, NONDETERMINISTIC);
  1650.  
  1651.   notify_registered_foreign(fdef, m);
  1652.  
  1653.   succeed;
  1654. }  
  1655.  
  1656.  
  1657. bool
  1658. PL_load_extensions(PL_extension *ext)
  1659. { PL_extension *e;
  1660.   Module m;
  1661.  
  1662.   m = (environment_frame ? contextModule(environment_frame)
  1663.              : MODULE_system);
  1664.  
  1665.   for(e = ext; e->predicate_name; e++)
  1666.   { short flags = TRACE_ME;
  1667.     register Definition def;
  1668.     register Procedure proc;
  1669.  
  1670.     if ( e->flags & PL_FA_NOTRACE )         flags &= ~TRACE_ME;
  1671.     if ( e->flags & PL_FA_TRANSPARENT )         flags |= METAPRED;
  1672.     if ( e->flags & PL_FA_NONDETERMINISTIC ) flags |= NONDETERMINISTIC;
  1673.  
  1674.     proc = lookupProcedure(lookupFunctorDef(lookupAtom(e->predicate_name),
  1675.                         e->arity), 
  1676.                m);
  1677.     def = proc->definition;
  1678.     if ( true(def, LOCKED) )
  1679.     { warning("PL_load_extensions(): Attempt to redefine system predicate: %s",
  1680.           procedureName(proc));
  1681.       continue;
  1682.     }
  1683.     if ( def->definition.function )
  1684.       warning("PL_load_extensions(): redefined %s", procedureName(proc));
  1685.     if ( false(def, FOREIGN) && def->definition.clauses != NULL )
  1686.       abolishProcedure(proc, m);
  1687.     set(def, FOREIGN);
  1688.     set(def, flags);
  1689.     def->definition.function = e->function;
  1690.     def->indexPattern = 0;
  1691.     def->indexCardinality = 0;
  1692.  
  1693.     notify_registered_foreign(def->functor->functor, m);
  1694.   }    
  1695.  
  1696.   succeed;
  1697. }
  1698.  
  1699.          /*******************************
  1700.          *     EMBEDDING PROLOG    *
  1701.          *******************************/
  1702.  
  1703. int
  1704. PL_toplevel(void)
  1705. { return prolog(lookupAtom("$toplevel"));
  1706. }
  1707.  
  1708.  
  1709. void
  1710. PL_halt(int status)
  1711. { Halt(status);
  1712. }
  1713.  
  1714.  
  1715.         /********************************
  1716.         *            SIGNALS            *
  1717.         *********************************/
  1718.  
  1719. #if HAVE_SIGNAL
  1720. void
  1721. (*PL_signal(int sig, void (*func) (int)))(int)
  1722. { void (*old)(int);
  1723.  
  1724.   if ( sig < 1 || sig > MAXSIGNAL )
  1725.   { fatalError("PL_signal(): illegal signal number: %d", sig);
  1726.     return NULL;
  1727.   }
  1728.  
  1729.   if ( LD_sig_handler(sig).catched == FALSE )
  1730.   { old = signal(sig, func);
  1731.     LD_sig_handler(sig).os = func;
  1732.     
  1733.     return old;
  1734.   }
  1735.  
  1736.   old = LD_sig_handler(sig).user;
  1737.   LD_sig_handler(sig).user = func;
  1738.  
  1739.   return old;
  1740. }
  1741. #endif
  1742.  
  1743. void
  1744. PL_raise(int sig)
  1745. { if ( sig > 0 && sig <= MAXSIGNAL )
  1746.     signalled |= (1L << (sig-1));
  1747. }
  1748.  
  1749.  
  1750.         /********************************
  1751.         *         RESET (ABORTS)    *
  1752.         ********************************/
  1753.  
  1754. struct abort_handle
  1755. { AbortHandle      next;            /* Next handle */
  1756.   PL_abort_hook_t function;        /* The handle itself */
  1757. };
  1758.  
  1759. #define abort_head (LD->fli._abort_head)
  1760. #define abort_tail (LD->fli._abort_tail)
  1761.  
  1762. void
  1763. PL_abort_hook(PL_abort_hook_t func)
  1764. { AbortHandle h = (AbortHandle) allocHeap(sizeof(struct abort_handle));
  1765.   h->next = NULL;
  1766.   h->function = func;
  1767.  
  1768.   if ( abort_head == NULL )
  1769.   { abort_head = abort_tail = h;
  1770.   } else
  1771.   { abort_tail->next = h;
  1772.     abort_tail = h;
  1773.   }
  1774. }
  1775.  
  1776.  
  1777. int
  1778. PL_abort_unhook(PL_abort_hook_t func)
  1779. { AbortHandle h = abort_head;
  1780.  
  1781.   for(; h; h = h->next)
  1782.   { if ( h->function == func )
  1783.     { h->function = NULL;
  1784.       return TRUE;
  1785.     }
  1786.   }
  1787.  
  1788.   return FALSE;
  1789. }
  1790.  
  1791.  
  1792. void
  1793. resetForeign(void)
  1794. { AbortHandle h = abort_head;
  1795.  
  1796.   for(; h; h = h->next)
  1797.     if ( h->function )
  1798.       (*h->function)();
  1799. }
  1800.  
  1801.  
  1802.         /********************************
  1803.         *        FOREIGN INITIALISE    *
  1804.         ********************************/
  1805.  
  1806. struct initialise_handle
  1807. { InitialiseHandle      next;            /* Next handle */
  1808.   PL_initialise_hook_t function;        /* The handle itself */
  1809. };
  1810.  
  1811. #define initialise_head (LD->fli._initialise_head)
  1812. #define initialise_tail (LD->fli._initialise_tail)
  1813.  
  1814. void
  1815. PL_initialise_hook(PL_initialise_hook_t func)
  1816. { InitialiseHandle h = initialise_head;
  1817.  
  1818.   for(; h; h = h->next)
  1819.   { if ( h->function == func )
  1820.       return;                /* already there */
  1821.   }
  1822.  
  1823.   h = (InitialiseHandle) malloc(sizeof(struct initialise_handle));
  1824.  
  1825.   h->next = NULL;
  1826.   h->function = func;
  1827.  
  1828.   if ( initialise_head == NULL )
  1829.   { initialise_head = initialise_tail = h;
  1830.   } else
  1831.   { initialise_tail->next = h;
  1832.     initialise_tail = h;
  1833.   }
  1834. }
  1835.  
  1836.  
  1837. void
  1838. initialiseForeign(int argc, char **argv)
  1839. { InitialiseHandle h = initialise_head;
  1840.  
  1841.   for(; h; h = h->next)
  1842.     (*h->function)(argc, argv);
  1843. }
  1844.  
  1845.  
  1846.          /*******************************
  1847.          *          PROMPT        *
  1848.          *******************************/
  1849.  
  1850. void
  1851. PL_prompt1(const char *s)
  1852. { prompt1((char *) s);
  1853. }
  1854.  
  1855.  
  1856. int
  1857. PL_ttymode(int fd)
  1858. { if ( fd == 0 )
  1859.   { if ( GD->cmdline.notty )        /* -tty in effect */
  1860.       return PL_NOTTY;
  1861.     if ( ttymode == TTY_RAW )        /* get_single_char/1 and friends */
  1862.       return PL_RAWTTY;
  1863.     return PL_COOKEDTTY;        /* cooked (readline) input */
  1864.   } else
  1865.     return PL_NOTTY;
  1866. }
  1867.  
  1868.  
  1869. void
  1870. PL_write_prompt(int fd, int dowrite)
  1871. { if ( fd == 0 )
  1872.   { if ( dowrite )
  1873.     { extern int Output;
  1874.       int old = Output;
  1875.       Output = 1;
  1876.       Putf("%s", PrologPrompt());
  1877.       pl_flush();
  1878.       Output = old;
  1879.     }
  1880.  
  1881.     pl_ttyflush();
  1882.     GD->os.prompt_next = FALSE;
  1883.   }
  1884. }
  1885.  
  1886.  
  1887. void
  1888. PL_prompt_next(int fd)
  1889. { if ( fd == 0 )
  1890.     GD->os.prompt_next = TRUE;
  1891. }
  1892.  
  1893.  
  1894. char *
  1895. PL_prompt_string(int fd)
  1896. { if ( fd == 0 )
  1897.     return PrologPrompt();
  1898.  
  1899.   return "";
  1900. }
  1901.  
  1902.  
  1903. void
  1904. PL_add_to_protocol(const char *buf, int n)
  1905. { protocol((char *)buf, n);
  1906. }
  1907.  
  1908.  
  1909.          /*******************************
  1910.          *       DISPATCHING        *
  1911.          *******************************/
  1912.  
  1913. #define dispatch_events (LD->fli._dispatch_events)
  1914.  
  1915. PL_dispatch_hook_t
  1916. PL_dispatch_hook(PL_dispatch_hook_t hook)
  1917. { PL_dispatch_hook_t old = dispatch_events;
  1918.  
  1919.   dispatch_events = hook;
  1920.   return old;
  1921. }
  1922.  
  1923. int
  1924. PL_dispatch(int fd, int wait)
  1925. { int rval;
  1926.  
  1927.   if ( wait == PL_DISPATCH_INSTALLED )
  1928.     return dispatch_events ? TRUE : FALSE;
  1929.  
  1930.   if ( dispatch_events )
  1931.   { do
  1932.     { rval = (*dispatch_events)(fd);
  1933.     } while( wait == PL_DISPATCH_WAIT && rval == PL_DISPATCH_TIMEOUT );
  1934.   } else
  1935.     rval = PL_DISPATCH_INPUT;
  1936.  
  1937.   return rval;
  1938. }
  1939.  
  1940.  
  1941.          /*******************************
  1942.          *        FEATURES        *
  1943.          *******************************/
  1944.  
  1945. int
  1946. PL_set_feature(const char *name, int type, ...)
  1947. { va_list args;
  1948.   int rval = TRUE;
  1949.  
  1950.   va_start(args, type);
  1951.   switch(type)
  1952.   { case PL_ATOM:
  1953.     { char *v = va_arg(args, char *);
  1954.       setFeature(lookupAtom(name), FT_ATOM, lookupAtom(v));
  1955.       break;
  1956.     }
  1957.     case PL_INTEGER:
  1958.     { long v = va_arg(args, long);
  1959.       setFeature(lookupAtom(name), FT_INTEGER, v);
  1960.       break;
  1961.     }
  1962.     default:
  1963.       rval = FALSE;
  1964.   }
  1965.  
  1966.   va_end(args);
  1967.   return rval;
  1968. }
  1969.  
  1970.  
  1971.         /********************************
  1972.         *           WARNINGS            *
  1973.         *********************************/
  1974.  
  1975. bool
  1976. PL_warning(const char *fm, ...)
  1977. { va_list args;
  1978.  
  1979.   va_start(args, fm);
  1980.   vwarning(fm, args);
  1981.   va_end(args);
  1982.  
  1983.   fail;
  1984. }
  1985.  
  1986. void
  1987. PL_fatal_error(const char *fm, ...)
  1988. { va_list args;
  1989.  
  1990.   va_start(args, fm);
  1991.   vfatalError(fm, args);
  1992.   va_end(args);
  1993. }
  1994.  
  1995.  
  1996.         /********************************
  1997.         *            ACTIONS            *
  1998.         *********************************/
  1999.  
  2000. int
  2001. PL_action(int action, ...)
  2002. { int rval;
  2003.   va_list args;
  2004.  
  2005.   va_start(args, action);
  2006.  
  2007.   switch(action)
  2008.   { case PL_ACTION_TRACE:
  2009.       rval = pl_trace();
  2010.       break;
  2011.     case PL_ACTION_DEBUG:
  2012.       rval = pl_debug();
  2013.       break;
  2014.     case PL_ACTION_BACKTRACE:
  2015. #ifdef O_DEBUGGER
  2016.     { int a = va_arg(args, int);
  2017.  
  2018.       if ( gc_status.active )
  2019.       { Sfprintf(Serror,
  2020.          "\n[Cannot print stack while in %ld-th garbage collection]\n",
  2021.          gc_status.collections);
  2022.     fail;
  2023.       }
  2024.       if ( GD->bootsession || !GD->initialised )
  2025.       { Sfprintf(Serror,
  2026.          "\n[Cannot print stack while initialising]\n");
  2027.     fail;
  2028.       }
  2029.       backTrace(environment_frame, a);
  2030.       rval = TRUE;
  2031.     }
  2032. #else
  2033.       warning("No Prolog backtrace in runtime version");
  2034.       rval = FALSE;
  2035. #endif
  2036.       break;
  2037.     case PL_ACTION_BREAK:
  2038.       rval = pl_break();
  2039.       break;
  2040.     case PL_ACTION_HALT:
  2041.     { int a = va_arg(args, int);
  2042.  
  2043.       Halt(a);
  2044.       rval = FALSE;
  2045.       break;
  2046.     }
  2047.     case PL_ACTION_ABORT:
  2048.       rval = pl_abort();
  2049.       break;
  2050.     case PL_ACTION_SYMBOLFILE:
  2051.     { char *name = va_arg(args, char *);
  2052.       loaderstatus.symbolfile = lookupAtom(name);
  2053.       rval = TRUE;
  2054.       break;
  2055.     }
  2056.     case PL_ACTION_WRITE:
  2057.     { char *s = va_arg(args, char *);
  2058.       Putf("%s", (char *)s);
  2059.       rval = TRUE;
  2060.       break;
  2061.     }
  2062.     case PL_ACTION_FLUSH:
  2063.       rval = pl_flush();
  2064.       break;
  2065.     default:
  2066.       sysError("PL_action(): Illegal action: %d", action);
  2067.       /*NOTREACHED*/
  2068.       rval = FALSE;
  2069.   }
  2070.  
  2071.   va_end(args);
  2072.  
  2073.   return rval;
  2074. }
  2075.  
  2076.         /********************************
  2077.         *         QUERY PROLOG          *
  2078.         *********************************/
  2079.  
  2080. #define c_argc (GD->cmdline._c_argc)
  2081. #define c_argv (GD->cmdline._c_argv)
  2082.  
  2083. static void
  2084. init_c_args()
  2085. { if ( c_argc == -1 )
  2086.   { int i;
  2087.     int argc    = GD->cmdline.argc;
  2088.     char **argv = GD->cmdline.argv;
  2089.  
  2090.     c_argv = allocHeap(argc * sizeof(char *));
  2091.     c_argv[0] = argv[0];
  2092.     c_argc = 1;
  2093.  
  2094.     for(i=1; i<argc; i++)
  2095.     { if ( argv[i][0] == '-' )
  2096.       { switch(argv[i][1])
  2097.     { case 'x':
  2098.       case 'g':
  2099.       case 'd':
  2100.       case 'f':
  2101.       case 't':
  2102.         i++;
  2103.         continue;
  2104.       case 'B':
  2105.       case 'L':
  2106.       case 'G':
  2107.       case 'O':
  2108.       case 'T':
  2109.       case 'A':
  2110.         continue;
  2111.     }
  2112.       }
  2113.       c_argv[c_argc++] = argv[i];
  2114.     }
  2115.   }
  2116. }
  2117.  
  2118.  
  2119. long
  2120. PL_query(int query)
  2121. { switch(query)
  2122.   { case PL_QUERY_ARGC:
  2123.       init_c_args();
  2124.       return (long) c_argc;
  2125.     case PL_QUERY_ARGV:
  2126.       init_c_args();
  2127.       return (long) c_argv;
  2128.     case PL_QUERY_SYMBOLFILE:
  2129.       if ( !getSymbols() )
  2130.     return (long) NULL;
  2131.       return (long) stringAtom(loaderstatus.symbolfile);
  2132.     case PL_QUERY_ORGSYMBOLFILE:
  2133.       if ( getSymbols() == FALSE )
  2134.     return (long) NULL;
  2135.       return (long) stringAtom(loaderstatus.orgsymbolfile);
  2136.     case PL_QUERY_MAX_INTEGER:
  2137.       return PLMAXINT;
  2138.     case PL_QUERY_MIN_INTEGER:
  2139.       return PLMININT;
  2140.     case PL_QUERY_MAX_TAGGED_INT:
  2141.       return PLMAXTAGGEDINT;
  2142.     case PL_QUERY_MIN_TAGGED_INT:
  2143.       return PLMINTAGGEDINT;
  2144.     case PL_QUERY_GETC:
  2145.       PopTty(&ttytab);            /* restore terminal mode */
  2146.       return (long) Sgetchar();        /* normal reading */
  2147.     case PL_QUERY_VERSION:
  2148.       return PLVERSION;
  2149.     default:
  2150.       sysError("PL_query: Illegal query: %d", query);
  2151.       /*NOTREACHED*/
  2152.       fail;
  2153.   }
  2154. }
  2155.  
  2156.